home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992…tember: A ROM With a View / devSep92 / devSep92.dmg / Development Platforms / LISP Related / MCL Networking / Network / NBP.lisp < prev    next >
Encoding:
Text File  |  1990-08-31  |  11.4 KB  |  302 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Copyright 1987, 1988, 1989, 1990 by Ruben Kleiman for Apple Computer, Inc.
  3. ;;; Advanced Technology Group
  4. ;;;
  5. ;;; Acknowledgements: Thanks to Matthew MacLaurin for tweaking LOOKUP-NAMES
  6. ;;;                   and for adding NBP-LOOKUP-NAMES
  7. ;;;                   Thanks to Bill Luciw for doing the arithmetic bit on LOOKUP-NAMES
  8. ;;;
  9.  
  10. ;;;
  11. ;;; NBP AppleTalk Driver
  12. ;;;
  13.  
  14.  
  15. (in-package :network :use '(ccl system lisp))
  16.  
  17. (export '(check-nbp-driver
  18.           NBP-lookup))
  19.  
  20. (eval-when (eval load compile)
  21.   (require :traps)
  22.   (require :driver))
  23.  
  24. ;;; ------------------
  25. ;;; General offsets
  26. (defconstant $MPPIoRefNum -10)  ; The .MPP driver (used by .NBP)
  27. (defconstant $ioResult 16)
  28. ;;;(defconstant $ioRefNum 24)  ; from driver.lisp
  29. ;;;(defconstant $ioPermssn 27) ; from driver.lisp
  30. ;;;(defconstant $csCode 26)    ; from driver.lisp
  31. (defconstant $interval 28)     ; byte
  32. (defconstant $count 29)        ; byte
  33. (defconstant $ntQElPtr 30)     ; pointer
  34. (defconstant $verifyFlag 34)   ; byte
  35. (defconstant $entityPtr 30)    ; pointer
  36. (defconstant $retBuffPtr 34)   ; pointer
  37. (defconstant $retBuffSize 38)  ; word
  38. (defconstant $maxToGet 40)     ; word
  39. (defconstant $numGotten 42)    ; word
  40.  
  41. (defconstant $tupleNet 0)
  42. (defconstant $tupleNode 2)
  43. (defconstant $tupleSkt 3)
  44.  
  45. ;;; ------------------
  46. ;;; Entity Name Record Offsets
  47. (defconstant $NextEntryPtr 0)  ; longword
  48. (defconstant $Net 4)           ; word
  49. (defconstant $Node 6)          ; byte
  50. (defconstant $Skt 7)           ; byte
  51. (defconstant $Name 9)          ; start of name string
  52.  
  53. ;;; ------------------
  54. ;;; Send self flags
  55. (defconstant $setSelfSend 256)
  56. (defconstant $NewSelfFlag 28)   ; byte
  57. (defconstant $OldSelfFlag 29)   ; byte
  58.  
  59. ;;; ------------------
  60. ;;; NBP Routine CsCodes
  61. (defconstant $registerName 253)
  62. (defconstant $confirmName 250)
  63. (defconstant $removeName 252)
  64. (defconstant $loadNBP 249)
  65. (defconstant $lookUpName 251)
  66.  
  67. (defrecord EntityName
  68.   (objStr (string 32))
  69.   (typeStr (string 32))
  70.   (zoneStr (string 32)))
  71.  
  72. ;;; -------------------------------------------------------------------------
  73. ;;; *nbp-driver* DEFINITIONS
  74.  
  75. (defobject *nbp-driver* nil)
  76.  
  77. ;;; Note: We are actually interfacing with the MPP driver throughout this!
  78. (defobfun (exist *nbp-driver*) (init-list)
  79.   (usual-exist init-list)
  80.   (have 'driver-name (getf init-list :driver-name ".NBP"))
  81.   (have 'driver-open-p nil)
  82.   (have 'driver-pb (_NewPtr :errchk :d0 80 :a0))
  83.   (%put-byte driver-pb 0 $ioPermssn)
  84.   (%put-word driver-pb $MPPIoRefNum $ioRefNum))   ; the .NBP "driver" actually uses the .MPP driver!
  85.  
  86. ;;; --------------------------------------------
  87. ;;; Some generic functions
  88.  
  89.  
  90. (defun make-AddrBlock (&key (aNet 0) (aNode 0) (aSocket 0))
  91.   (+ (* aNet 65536) (* aNode 256) aSocket))
  92.  
  93. (defvar *the-NBP-driver* nil)
  94.  
  95. (defun check-NBP-driver ()
  96.   "Create and open the NBP driver, if necessary"
  97.   (or *the-NBP-driver*
  98.       (setq *the-NBP-driver* (oneOf *nbp-driver*)))
  99.   (or (ask *the-NBP-driver* driver-open-p)
  100.       (ask *the-NBP-driver* (driver-open))))
  101.  
  102. (defun NBP-register (name type socket)
  103.   (ask *the-NBP-driver* (register-name name type socket)))
  104.  
  105. (defun NBP-unregister (name type)
  106.   (ask *the-NBP-driver* (unregister-name name type)))
  107.  
  108. (defun NBP-lookup (name type)
  109.   (ask *the-NBP-driver* (lookup-single-name name type)))
  110.  
  111. (defun NBP-lookup-names (type)               ;m000
  112.   (ask *the-NBP-driver* (lookup-names type)))
  113.  
  114. (defun allow-local-loopback ()
  115.   (check-nbp-driver)
  116.   (ask *the-NBP-driver* (SetSelfSend)))
  117.  
  118. (defun NBP-handle-error (ioResult)
  119.   (or (= ioResult 0)
  120.       (= ioResult 1)
  121.       (cerror "KEEP ON TRUCKIN' ..."
  122.              (case ioResult
  123.                (-1024 "NBP buffer overflow (~a)")
  124.                (-1026 "NBP name confirmed for different socket (~a)")
  125.                (-1027 "NBP duplicate name already exists (~a)")
  126.                (-1029 "NBP names information socket error (~a)")
  127.                (-1025 "NBP name not confirmed (~a)")
  128.                (-1028 "NBP name not found (~a)")
  129.                (-1029 "NBP names information socket error (~a)")
  130.                (-3104 "NBP can't find tuple in buffer (~a)")
  131.                (OTHERWISE "ADSP Unknown error (~a)"))
  132.              ioResult)))
  133.  
  134. ;;; --------------------------------------------
  135.  
  136. ;;; Methods:
  137. ;;;   driver-open ::= Will load the NBP driver into your system (usually already there)
  138. ;;;   register-name ::= Give it an existing socket number, a name & type for it,
  139. ;;;                        and it will register it in the AppleTalk network for you.
  140. ;;;   unregister-name ::= Give it a socket number, and it will unregister
  141. ;;;                          it from the AppleTalk network.
  142. ;;;   lookup-name ::= Give it an entity name pointer, and it will tell you
  143. ;;;                      whether anyone is registered in the network with that name.
  144. ;;;   SetSelfSend ::= Makes sure that your system can send messages to itself
  145.  
  146. (defobfun (driver-control *nbp-driver*) (code)
  147.   "Do a driver control trap"
  148.   (if (not driver-open-p) (error "Driver: ~s is not open" (self)))
  149.   (%put-word driver-pb code $csCode)
  150.   (_Control :a0 driver-pb))
  151.  
  152. (defobfun (SetSelfSend *nbp-driver*) (&optional (on 1))
  153.   "Enables node to talk to itself"
  154.   (%put-byte driver-pb on $NewSelfFlag)
  155.   (driver-control $setSelfSend)
  156.   (NBP-handle-error (%get-signed-word driver-pb $ioResult)))
  157.  
  158. (defobfun (driver-open *nbp-driver*) ()
  159.   "Load NBP Services"
  160.   (setq driver-open-p t)
  161.   (driver-control $loadNBP)
  162.   (NBP-handle-error (%get-signed-word driver-pb $ioResult)))
  163.  
  164. (defobfun (register-name *nbp-driver*)
  165.           (name type socket &optional (node 0) &key (check-duplicate-p t) &aux NameTablePtr)
  166.   "Registers socket at node under name of given type"
  167.   (check-nbp-driver)
  168.   (setq NameTablePtr  ; should probably use a %stack-block let here...
  169.         (_NewPtr :check-error :d0 (+ (length name) (length type) 20) :a0))   ; becomes property of NBP
  170.   (%put-byte driver-pb 8 $interval)
  171.   (%put-byte driver-pb 3 $count)
  172.   (%put-byte driver-pb check-duplicate-p $verifyFlag)
  173.   ;; Fill-in name table entry
  174.   (%put-word NameTablePtr 0 $Net)
  175.   (%put-byte NameTablePtr node $Node)
  176.   (%put-byte NameTablePtr socket $Skt)
  177.   (%put-string NameTablePtr name $Name)
  178.   (%put-string NameTablePtr type (+ $Name (length name) 1))
  179.   (%put-string NameTablePtr "*" (+ $Name (length name) (length type) 2))
  180.   (%put-ptr driver-pb NameTablePtr $ntQElPtr)
  181.  
  182.   (driver-control $registerName)
  183.   (NBP-handle-error (%get-signed-word driver-pb $ioResult)))
  184.  
  185. (defobfun (unregister-name *nbp-driver*) (name type)
  186.   "Unregisters socket"
  187.   (check-nbp-driver)
  188.   (%stack-block ((entityNamePtr 70))
  189.     (%put-string entityNamePtr name)
  190.     (%put-string entityNamePtr type (+ (length name) 1))
  191.     (%put-string entityNamePtr "*" (+ (length name) (length type) 2))
  192.     (%put-ptr driver-pb entityNamePtr $entityPtr)
  193.  
  194.     (driver-control $removeName)
  195.     (NBP-handle-error (%get-signed-word driver-pb $ioResult))))
  196.  
  197. (defobfun (lookup-single-name *nbp-driver*) (name type)
  198.   "Check whether server of name and type is registered and return its internet address"
  199.   (check-nbp-driver)
  200.   (%stack-block ((entityNamePtr 70)
  201.                  (lookUpDataPtr 40))     ; where answers will be deposited
  202.     (%put-string entityNamePtr name)
  203.     (%put-string entityNamePtr type (+ (length name) 1))
  204.     (%put-string entityNamePtr "*" (+ (length name) (length type) 2))
  205.     (%put-ptr driver-pb entityNamePtr $entityPtr)
  206.     (%put-ptr driver-pb lookUpDataPtr $retBuffPtr)
  207.     (%put-byte driver-pb 1 $interval)
  208.     (%put-byte driver-pb 3 $count)
  209.     (%put-word driver-pb 40 $retBuffSize)
  210.     (%put-word driver-pb 3 $maxToGet)
  211.     (%put-word driver-pb 0 $numGotten)
  212.     
  213.     (driver-control $lookUpName)
  214.     (NBP-handle-error (%get-signed-word driver-pb $ioResult))
  215.     
  216.     (cond ((> (%get-word driver-pb $numGotten) 0)  ; succeeded!
  217.            (values t
  218.                    (make-AddrBlock :aNet (%get-word lookupDataPtr $tupleNet)
  219.                                    :aNode (%get-byte lookupDataPtr $tupleNode)
  220.                                    :aSocket (%get-byte lookupDataPtr $tupleSkt))))
  221.           ((= (%get-byte driver-pb $count) 0) nil))))      ; failed
  222.  
  223.  
  224. (defobfun (lookup-names *nbp-driver*) (type)
  225.   "Returns internet addresses for servers registered under this type"
  226.   (check-nbp-driver)
  227.   (%stack-block ((entityNamePtr 70)
  228.                  (lookUpDataPtr 320))
  229.     (%put-string entityNamePtr "=")
  230.     (%put-string entityNamePtr type 2)
  231.     (%put-string entityNamePtr "*" (+ 3 (length type)))
  232.     (%put-ptr driver-pb entityNamePtr $entityPtr)
  233.     (%put-ptr driver-pb lookUpDataPtr $retBuffPtr)
  234.     (%put-byte driver-pb 1 $interval)
  235.     (%put-byte driver-pb 3 $count)
  236.     (%put-word driver-pb 320 $retBuffSize)
  237.     (%put-word driver-pb  8 $maxToGet)
  238.     (%put-word driver-pb 0 $numGotten)
  239.  
  240.     (driver-control $lookUpName)
  241.     (NBP-handle-error (%get-signed-word driver-pb $ioResult))
  242.  
  243.  (let ((ofst 0) (tmp 0) (addresses '()))      ;m000
  244.     (cond ((> (%get-word driver-pb $numGotten) 0)
  245.            (values t
  246.                    (dotimes (n (%get-word driver-pb $numGotten)
  247.                                (if (= 1 (length addresses))
  248.                                  (car addresses)
  249.                                  addresses))
  250.                      (push (make-AddrBlock :aNet (%get-word lookupDataPtr
  251.                                                             ofst)
  252.                                            :aNode (%get-byte lookupDataPtr 
  253.                                                              (+ ofst 2))
  254.                                            :aSocket (%get-byte lookupDataPtr
  255.                                                                (+ ofst 3)))
  256.                            addresses)
  257.                      (setq tmp (%get-byte lookupDataPtr (+ ofst 5)))
  258.                      (setq tmp (+ tmp (%get-byte lookupDataPtr (+ ofst tmp 6))))
  259.                      (setq tmp (+ tmp (%get-byte lookupDataPtr (+ ofst tmp 7))))
  260.                      (setq ofst (+ ofst tmp 8))
  261.                      )))
  262.           ((= (%get-byte driver-pb $count) 0) nil)))))
  263.  
  264. (defobfun (lookup-anames *nbp-driver*) (type)
  265.   "Returns object names for servers registered under this type"
  266.   (check-nbp-driver)
  267.   (%stack-block ((entityNamePtr 70)
  268.                  (lookUpDataPtr 320))
  269.     (%put-string entityNamePtr "=")
  270.     (%put-string entityNamePtr type 2)
  271.     (%put-string entityNamePtr "*" (+ 3 (length type)))
  272.     (%put-ptr driver-pb entityNamePtr $entityPtr)
  273.     (%put-ptr driver-pb lookUpDataPtr $retBuffPtr)
  274.     (%put-byte driver-pb 1 $interval)
  275.     (%put-byte driver-pb 3 $count)
  276.     (%put-word driver-pb 320 $retBuffSize)
  277.     (%put-word driver-pb  8 $maxToGet)
  278.     (%put-word driver-pb 0 $numGotten)
  279.  
  280.     (driver-control $lookUpName)
  281.     (NBP-handle-error (%get-signed-word driver-pb $ioResult))
  282.  
  283.  (let ((ofst 0) (tmp 0) (names nil)) 
  284.     (cond ((> (%get-word driver-pb $numGotten) 0)
  285.            (values t
  286.                    (dotimes (n (%get-word driver-pb $numGotten)
  287.                                (if (= 1 (length names))
  288.                                  (car names)
  289.                                  names))
  290.                      (push (%get-string lookupDataPtr (+ ofst 5))
  291.                                                        names)
  292.                      (setq tmp (%get-byte lookupDataPtr (+ ofst 5)))
  293.                      (setq tmp (+ tmp (%get-byte lookupDataPtr (+ ofst tmp 6))))
  294.                      (setq tmp (+ tmp (%get-byte lookupDataPtr (+ ofst tmp 7))))
  295.                      (setq ofst (+ ofst tmp 8))
  296.                      )))
  297.           ((= (%get-byte driver-pb $count) 0) nil)))))
  298.  
  299.  
  300.  
  301. (push :nbp *features*)
  302. (provide :nbp)